perm filename RVRS.F4[MSS,LCS]3 blob sn#200592 filedate 1976-02-11 generic text, type T, neo UTF8
00100		SUBROUTINE RVRS(IT)
00200		COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
00300		K=1
00400	
00500	1	J=KPN(K)
00600		R=Q(J+1)
00700		IF(R.NE.1)GO TO 2
00800	C  JUMP IF NOT A NOTE
00900		IF(Q(J+5).LT.10)GO TO 10
01000	C  JUMP IF NO STEM ON IT
01100		KK=K+1
01200	3	IF(KK.GT.IT)RETURN
01300		JJ=KPN(KK)
01400		RR=Q(JJ+1)
01500		IF(RR.NE.1)GO TO 5
01600	C  JUMP IF NOT A NOTE
01700		IF(Q(JJ+5).GE.10)GO TO 6
01800	C SKIP CHORD NOTES (NO STEM)
01900	7	KK=KK+1
02000		GO TO 3
02100	C DID NOT FIND BEAM NEARBY
02200	6	RZ=AMOD(Q(J+4),100.0)
02300		N=J+5
02400		A=10
02500		IF(RZ.GE.7)GO TO 60
02600		IF(Q(N).LT.20)GO TO 10
02700	C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
02800		A=-A
02900		GO TO 15
03000	60	IF(Q(N).GE.20)GO TO 10
03100	C  THERE MUST BE A BETTER WAY!
03200	15	Q(N)=Q(N)+A
03300		GO TO 10
03400	8	IF(Q(N).LT.20)GO TO 10
03500		A=-A
03600	C  STEM UP
03700		GO TO 15
03800	5	IF(RR.NE.6)GO TO 6
03900	20	B=Q(JJ+4)
04000		C=Q(JJ+5)
04100		D=(B+C)/2.
04200		IF(RR.EQ.5)GO TO 9
04300		IF(RR.NE.6)GO TO 10
04400		B=Q(JJ+6)+1.
04500	C  SAVES RANGE OF BEAM +1.
04600		IF(Q(JJ+7).GE.20)GO TO 11
04700	C  NOW STEMS ARE UP
04800		IF(D.LT.7)GO TO 12
04900	C JUMP TO 12 IF ALL OK
05000	CC	C=-10
05100		JSTM=0 
05200	C SAVE FOR REVERSED STEMS
05300		GO TO 23
05400	11	IF(D.GE.7.)GO TO 12
05500	C  STEMS DOWN
05600	C JUMP IF NO REVERSE NEEDED
05700		JSTM=-1
05800	23	JH=0
05810		CHNG=0
05900		DO 16 N=K,IT
06000		KK=KPN(N)
06100		IF(Q(KK+3).GT.B)GO TO 140
06200		R=Q(KK+1)
06300		IF(R.NE.1)GO TO 17
06400		L=5
06500		R=Q(KK+8)
06600	C  THE STEM LENGTH
06700		IF(R.EQ.999)R=0
06800		Q(KK+8)=-R
06900	C  FOR THE INVERSION
07000	19	C=10.
07100		A=Q(KK+L)
07200		IF(A.GE.20)C=-C
07300		Q(KK+L)=C+A
07400		IF(JH.NE.0)GO TO 161
07500	C NEXT FOR 1ST NOTE UNDER BEAM
07600		JH=4
07700	160	R=Q(JJ+JH)-Q(KK+4)
07800		C=-1 
07900		IF(JSTM)GO TO 163
07920		C=R
07940		R=1
08000	C NOW STEMS UP
08100	163	IF(R.GT.C)GO TO 162
08200	C JUMP IF BEAM IS NOT TOO CLOSE TO NOTE
08300		CHNG=C-R
08320		IF(JSTM.EQ.0)CHNG=-CHNG
08400		JH=JJ+4
08500		Q(JH)=Q(JH)+CHNG
08600		JH=JH+1
08700		Q(JH)=Q(JH)+CHNG
08800	162	IF(L)GO TO 141
08900	C  FOR ESCAPE FROM LOOP
09000	161	JH=KK
09100	C  JH SAVES PTR TO LAST NOTE UNDER BEAM
09200		GO TO 16
09300	17	IF(R.NE.6)GO TO 18
09400	C NOW IT'S A BEAM
09500		L=7
09600		GO TO 19
09700	18	IF(R.NE.5)GO TO 16
09800	C NOW IT'S A SLUR
09900		C=-3.8
10000		IF(Q(KK+7))C=-C
10100		CALL SLRV(KK,C)
10200	C  TO REVERSE SLUR
10300	CC	Q(KK+7)=-Q(KK+7)
10400	16	CONTINUE
10500	C  SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
10600	140	KK=JH
10700		L=-1
10800		JH=5
10900	C GO BACK TO CHECK HGT OF LAST NOTE AND RIGHT END OF BEAM
11000		GO TO 160
11100	
11105	141	IF(CHNG.EQ.0)GO TO 14
11107		IF(CHNG)CHNG=-CHNG
11110		DO 142 N=K,IT
11120	C  TO READJUST STEMS UNDER REVERSED BEAMS
11130		KK=KPN(N)
11137		IF(Q(KK+3).GT.B)GO TO 14
11144		IF(Q(KK+1).NE.1)GO TO 142
11165		Q(KK+8)=Q(KK+8)+CHNG
11172	C  THE STEM LENGTH
11179	142	CONTINUE
11186		GO TO 14
11200	
11300	C NEXT FOR SLURS
11400	9	B=-3.8
11500		IF(Q(JJ+7))GO TO 24
11600		IF(D.GT.7)GO TO 10
11700	C JUMP TO LEAVE STEM UP
11800		GO TO 25
11900	24	IF(D.LT.5)GO TO 10
12000	C JUMP TO LEAVE STEM DOWN
12100		B=-B
12200	CC25	Q(JJ+4)=Q(JJ+4)+B
12300	CC	Q(JJ+5)=Q(JJ+5)+B
12400	CC	Q(JJ+7)=-R
12500	25	CALL SLRV(JJ,B)
12600		GO TO 10
12700	12	DO 13 N=K+1,IT
12800		KK=KPN(N)
12900	13	IF(Q(KK+3).GT.B)GO TO 14
13000	C  JUMP OUT WHEN PAST END OF BEAM.
13100	14	K=N-1
13200		GO TO 10
13300	
13400	2	IF(R.NE.6)GO TO 21
13500	22	JJ=J
13600		RR=R
13700		GO TO 20
13800	21	IF(R.EQ.5)GO TO 22
13900	10	IF(K.GT.IT)RETURN
14000		K=K+1
14100		GO TO 1
14200		END